The World of Computer Software/The World of Computer Software.iso/faq-s.zip/PROMPTS.PAS

Pascal/Delphi Source File | 1991-04-18 | 7KB | 336 lines

unit prompts;

{$R-,S-,I-,D-,F+,V-,B-,L+}

interface

uses dos,crt,
     general,scrnunit,scrninpt;

const maxprompts=50;

type prompttype=(number,strng,yesno,command);
     promptrecptr=^promptrec;
     promptrec=record
       ptype:prompttype;
       r1,r2:integer;
       x,y,len,inputwid:integer;
       text:string[80];
       yesnostr:array [false..true] of string[15];
       next,prev:promptrecptr;
       case prompttype of
         command:(dataptr:pointer);
         number:(numberptr:^integer);
         strng:(strptr:^string);
         yesno:(yesnoptr:^boolean)
     end;

     promptset=record
       barcolor,datacolor,choicecolor:integer;
       first,last,current:promptrecptr
     end;

procedure beginprompts (var p:promptset);
procedure addprompt (var p:promptset; t:prompttype; var data; xx,yy:integer;
                     ptext:string);
procedure setinputwid (var p:promptset; n:integer);
procedure drawprompt (var p:promptset);
procedure drawprompts (var p:promptset);
function  useprompts (var p:promptset):integer;
procedure freeprompts (var p:promptset);
procedure beginchoices (var p:promptset);
procedure addchoice (var p:promptset; ptext:string);
function  usechoices (var p:promptset):integer;
procedure freechoices (var p:promptset);
function bioskey:char;
function bioslook:char;

implementation


function bioslook:char;    (* Returns 255 if not keypressed *)
var r:registers;
begin
  if keypressed then begin
    r.ah:=1;
    intr ($16,r);
    if r.al=0
      then bioslook:=chr(r.ah+128)
      else bioslook:=chr(r.al)
  end else bioslook:=#255
end;

function bioswait:char;    (* Waits for a key but doesn't take it out *)
var k:char;
begin
  repeat
    k:=bioslook
  until ord(k)<>255;
  bioswait:=k
end;

function bioskey:char;
var r:registers;
begin
  r.ah:=0;
  intr ($16,r);
  if r.al=0
    then bioskey:=chr(r.ah+128)
    else bioskey:=chr(r.al)
end;

procedure beginprompts (var p:promptset);
begin
  with curwindowptr^ do begin
    p.barcolor:=barcolor;
    p.datacolor:=datacolor;
    p.choicecolor:=choicecolor
  end;
  p.first:=nil;
  p.last:=nil;
  p.current:=nil
end;

procedure addprompt (var p:promptset; t:prompttype; var data; xx,yy:integer;
                     ptext:string);
var n:integer;
    np:promptrecptr;
begin
  new (np);
  if p.first=nil
    then
      begin
        p.first:=np;
        p.last:=np;
        p.current:=np;
        np^.prev:=np;
        np^.next:=np
      end
    else
      begin
        p.first^.prev:=np;
        p.last^.next:=np;
        np^.prev:=p.last;
        np^.next:=p.first;
        p.last:=np
      end;
  with np^ do begin
    ptype:=t;
    x:=xx;
    y:=yy;
    len:=length(ptext);
    dataptr:=@data;
    text:=ptext;
    inputwid:=curwindowptr^.xsize-x-len;
    if inputwid<3 then begin
      writeln ('Not enough room for input box for prompt');
      halt (1)
    end;
    case t of
      strng:r1:=80;
      number:begin
        r1:=-maxint;
        r2:=maxint
      end;
      yesno:begin
        yesnostr[false]:='No';
        yesnostr[true]:='Yes'
      end
    end
  end
end;

procedure setinputwid (var p:promptset; n:integer);
begin
  p.last^.inputwid:=n
end;

function promptstr (var p:promptrec):string;
begin
  with p do
    case ptype of
      number:promptstr:=strr(numberptr^);
      strng:promptstr:=copy(strptr^,1,80);
      yesno:promptstr:=yesnostr[yesnoptr^];
      command:promptstr:='';
    end
end;

procedure drawaprompt (var ps:promptset; var p:promptrec);
var val:string[80];
begin
  with p do begin
    if inputwid>80 then begin
      writeln ('Invalid prompt');
      halt
    end;
    setcolor (ps.choicecolor);
    gotoxy (x,y);
    write (text);
    gotoxy (x+len,y);
    val:=copy(promptstr(p),1,inputwid);
    while length(val)<inputwid do val:=val+' ';
    setcolor (ps.datacolor);
    write (val);
  end
end;

procedure drawprompt (var p:promptset);
begin
  if p.last<>nil
    then drawaprompt (p,p.last^)
end;

procedure drawprompts (var p:promptset);
var pp,cnt,ns:promptrecptr;
begin
  pp:=p.first;
  if pp=nil then exit;
  repeat
    drawaprompt (p,pp^);
    pp:=pp^.next
  until pp=p.first
end;

function useprompts (var p:promptset):integer;
var done:boolean;
    k:char;
    cp:promptrecptr;
const inputable:set of prompttype=[strng,number];

  procedure imdone (retval:integer);
  begin
    useprompts:=retval;
    p.current:=cp;
    done:=true
  end;

  procedure getinput;
  var x:string;
  begin
    if cp^.ptype in inputable then begin
      setinputregion (cp^.x+cp^.len,cp^.x+cp^.len+cp^.inputwid-1,cp^.y);
      case cp^.ptype of
        strng:buflen:=cp^.r1;
        number:buflen:=6
      end;
      readln (x);
      case cp^.ptype of
        strng:cp^.strptr^:=x;
        number:cp^.numberptr^:=valu(x)
      end;
      drawaprompt (p,cp^)
    end
  end;

  procedure selected;
  var pp:promptrecptr;
      n:integer;
  begin
    pp:=p.first;
    n:=1;
    while pp<>cp do begin
      n:=n+1;
      pp:=pp^.next;
      if pp=p.first then halt(2)
    end;
    imdone (n)
  end;

  procedure normal (k:char);
  begin
    if (k>=#32) and (k<=#126) and (cp^.ptype in inputable) then begin
      getinput;
      exit
    end;
    case k of
      #27:imdone (0);
      #13:if cp^.ptype in inputable
            then
              begin
                k:=bioskey;
                setdefaultinput (promptstr(cp^));
                getinput
              end
            else selected;
      else selected
    end
  end;

  procedure extended (code:integer);
  var k:char;
  begin
    case code of
      72,75:cp:=cp^.prev;
      77,80:cp:=cp^.next;
      71:cp:=p.first;
      79:cp:=p.last;
      end;{else} begin
        selected;
        exit
    {  end}
    end;
    k:=bioskey
  end;

begin
  cp:=p.current;
  if cp=nil then cp:=p.first;
  if cp=nil then begin
    useprompts:=0;
    exit
  end;
  done:=false;
  repeat
    colorregion (cp^.x,cp^.x+{cp^.}25{len-1},cp^.y,p.barcolor);
    k:=bioswait;
    colorregion (cp^.x,cp^.x+{cp^.}25{len-1},cp^.y,p.choicecolor);
    if ord(k)>127 then extended(ord(k)-128) else normal(k)
  until done
end;

procedure freeprompts (var p:promptset);
var pp,n:promptrecptr;
begin
  pp:=p.first;
  if pp=nil then exit;
  repeat
    n:=pp^.next;
    dispose (pp);
    pp:=n
  until pp=p.first;
  p.first:=nil
end;

procedure beginchoices (var p:promptset);
begin
  beginprompts (p)
end;

procedure addchoice (var p:promptset; ptext:string);
var y:integer;
begin
  if p.last=nil
    then y:=1
    else y:=p.last^.y+1;
  addprompt (p,command,p,2,y,ptext)
end;

function usechoices (var p:promptset):integer;
var n:integer;
    k:char;
begin
  drawprompts (p);
  repeat
    usechoices:=useprompts (p)
  until bioskey in [#27,#13]
end;

procedure freechoices (var p:promptset);
begin
  freeprompts (p)
end;

end.